home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / magazine / drdobbs / 1987 / 02 / shammas.lst < prev   
File List  |  1980-01-01  |  29KB  |  922 lines
  1. Listing 1.  Turbo Pascal listing of a four-function calculator program.
  2.  
  3. PROGRAM Calculate;
  4. (* Four function calculator example *)
  5.  
  6. VAR OpError : BOOLEAN;
  7.     Operation, OK : CHAR;
  8.     X, Y, Result : REAL;
  9.  
  10. BEGIN
  11.     REPEAT
  12.         ClrScr;
  13.         WRITE('Enter first number '); READLN(X); WRITELN;
  14.         WRITE('Enter operation '); READLN(Operation); WRITELN;
  15.         WRITE('Enter second number '); READLN(Y); WRITELN;
  16.         OpError := FALSE;
  17.         CASE Operation OF
  18.             '+' : Result := X + Y;
  19.             '-' : Result := X - Y;
  20.             '*' : Result := X * Y;
  21.             '/' : IF Y <> 0.
  22.                   THEN
  23.                       Result := X / Y
  24.                   ELSE BEGIN
  25.                       WRITELN('Cannot divide by zero!');
  26.                       WRITELN;
  27.                       OpError := TRUE
  28.                   END
  29.             ELSE OpError := TRUE;
  30.         END; (* CASE *)
  31.         IF NOT OpError THEN BEGIN
  32.             WRITELN(X,'  ',Operation,'  ',Y,' = ',Result);
  33.             WRITELN;
  34.         END;
  35.         WRITE('Perform another operation? (Y/N) ');
  36.         READLN(OK); WRITELN;
  37.     UNTIL (OK <> 'Y') AND (OK <> 'y');
  38.  END.
  39.  
  40.  
  41.  
  42.  
  43. Listing 2. Modula-2 listing of a four-function calculator program.
  44.  
  45.  
  46. MODULE Calculate; 
  47.  
  48.   FROM ScreenHandler
  49.     IMPORT ClrEol, ClrScr, DelLine, InsLine, GotoXY, WhereX, WhereY,
  50.     CrtInit, CrtExit, LowVideo, NormVideo, HighVideo, SetAttribute,
  51.     GetAttribute, normalAtt, boldAtt, reverseAtt, underlineAtt,
  52.     blinkAtt, boldUnderlineAtt, blinkUnderlineAtt, boldBlinkAtt,
  53.     reverseBlinkAtt, boldUnderlineBlinkAtt;
  54.   FROM TRealIO IMPORT ReadReal, WriteReal;
  55.   FROM TTextIO
  56.     IMPORT ReadInt, ReadCard, ReadChar, ReadString, ReadLn, ReadBuffer,
  57.     WriteInt, WriteCard, WriteChar, WriteString, WriteBool, WriteLn,
  58.     Eoln, SeekEof, SeekEoln;
  59.   FROM TKernelIO
  60.     IMPORT File, FileType, OptionMode,
  61.     StatusProc, ReadProc, WriteProc, ErrorProc,
  62.     stdinout, input, output, con, trm, kbd, lst, aux, usr,
  63.     conStPtr, conInPtr, auxInPtr, usrInPtr, conOutPtr, lstOutPtr,
  64.     auxOutPtr, usrOutPtr, errorPtr, IOresult, KeyPressed, IOBuffer,
  65.     IOCheck, DeviceCheck, CtrlC, InputFileBuffer,  OutputFileBuffer;
  66.  
  67. (* Four function calculator example *) 
  68.  
  69.  
  70.   VAR 
  71.     OpError: BOOLEAN; 
  72.     Operation, OK: CHAR; 
  73.     X, Y, Result: REAL; 
  74.  
  75. BEGIN 
  76.   REPEAT 
  77.  
  78.     ClrScr; 
  79.     WriteString(stdinout, 'Enter first number ', 0); 
  80.     ReadBuffer(on); 
  81.     ReadReal(stdinout, X); 
  82.     ReadLn(stdinout); 
  83.     ReadBuffer(off); 
  84.     WriteLn(stdinout); 
  85.     WriteString(stdinout, 'Enter operation ', 0); 
  86.     ReadBuffer(on); 
  87.     ReadChar(stdinout, Operation); 
  88.     ReadLn(stdinout); 
  89.     ReadBuffer(off); 
  90.     WriteLn(stdinout); 
  91.     WriteString(stdinout, 'Enter second number ', 0); 
  92.     ReadBuffer(on); 
  93.     ReadReal(stdinout, Y); 
  94.     ReadLn(stdinout); 
  95.     ReadBuffer(off); 
  96.     WriteLn(stdinout); 
  97.     OpError := FALSE; 
  98.     CASE Operation OF 
  99.         '+': 
  100.         Result := X+Y
  101.       | '-': 
  102.         Result := X-Y
  103.       | '*': 
  104.         Result := X*Y
  105.       | '/': 
  106.         IF 
  107.         Y <> 0. THEN 
  108.  
  109.           Result := X/Y
  110.         ELSE 
  111.  
  112.           WriteString(stdinout, 'Cannot divide by zero!', 0); 
  113.           WriteLn(stdinout); 
  114.           WriteLn(stdinout); 
  115.  
  116.           OpError := TRUE
  117.         END
  118.       ELSE 
  119.         OpError := TRUE; 
  120.     END; (* CASE *) 
  121.     IF  NOT OpError THEN 
  122.  
  123.       WriteReal(stdinout, X, 18, -10); 
  124.       WriteString(stdinout, '  ', 0); 
  125.       WriteChar(stdinout, Operation, 0); 
  126.       WriteString(stdinout, '  ', 0); 
  127.       WriteReal(stdinout, Y, 18, -10); 
  128.       WriteString(stdinout, ' = ', 0); 
  129.       WriteReal(stdinout, Result, 18, -10); 
  130.       WriteLn(stdinout); 
  131.       WriteLn(stdinout); 
  132.     END; 
  133.     WriteString(stdinout, 'Perform another operation? (Y/N) ', 0); 
  134.     ReadBuffer(on); 
  135.     ReadChar(stdinout, OK); 
  136.     ReadLn(stdinout); 
  137.     ReadBuffer(off); 
  138.     WriteLn(stdinout); 
  139.   UNTIL (OK <> 'Y') AND (OK <> 'y'); 
  140. END Calculate.
  141.  
  142.  
  143.  
  144.  
  145.  
  146. Listing 3.  Turbo Pascal program for text pattern matching.
  147.  
  148.  
  149. PROGRAM Pattern_Search_Test;
  150.  
  151. (*$V-*)
  152.  
  153. CONST MAX = 100;
  154.       DEFAULT_LINE = 'Namir Clement Shammas';
  155.  
  156. TYPE STRING40 = STRING[40];
  157.      STRING80 = STRING[80];
  158.      STRING255 = STRING[255];
  159.  
  160. VAR Line : STRING255;
  161.     Pattern : STRING40;
  162.  
  163.  
  164. FUNCTION Pattern_Search(Text_Line : STRING255; Pattern : STRING40) : INTEGER;
  165. (* Scan Text_Line with Pattern string, containing possible *)
  166. (* combination of wildcards. *)
  167.  
  168. VAR Num_Tokens : INTEGER;
  169.     Token : ARRAY [1..MAX] OF STRING40;
  170.  
  171.  
  172. PROCEDURE INC(VAR A : INTEGER);
  173.  
  174. BEGIN
  175.     A := A + 1;
  176. END;
  177.  
  178.  
  179. FUNCTION Offset_Pos(Str1, Str2 : STRING80; Ptr : INTEGER) : INTEGER;
  180.  
  181. VAR Ptr2 : INTEGER;
  182.  
  183. BEGIN
  184.    Delete(Str1,1,Ptr-1);
  185.    Ptr2 := Pos(Str2, Str1);
  186.    IF Ptr2 > 0 THEN Ptr2 := Ptr2 + Ptr - 1;
  187.    Offset_Pos := Ptr2;
  188. END; (* Offset_Pos *)
  189.  
  190.  
  191. PROCEDURE Scan_Pattern;
  192.  
  193. VAR Char_Pos, Pattern_Length, Ptr, Ptr2  : INTEGER;
  194.  
  195. BEGIN
  196.     Char_Pos := 1; Num_Tokens := 0; Ptr := 1;
  197.     Pattern_Length := Length(Pattern);
  198.     WHILE Char_Pos <= Pattern_Length DO BEGIN
  199.         CASE Pattern[Char_Pos] OF
  200.             '?' : BEGIN
  201.                     IF Char_Pos > Ptr
  202.                     THEN BEGIN
  203.                         INC(Num_Tokens);
  204.                         Token[Num_Tokens] :=
  205.                             Copy(Pattern,Ptr,(Char_Pos - Ptr));
  206.                     END; (* IF *)
  207.                     Ptr2 := Char_Pos;
  208.                     WHILE Pattern[Ptr2] = '?' DO INC(Ptr2);
  209.                     INC(Num_Tokens);
  210.                     Token[Num_Tokens] :=
  211.                         Copy(Pattern,Char_Pos,(Ptr2 - Char_Pos));
  212.                     Ptr := Ptr2; Char_Pos := Ptr2
  213.                   END;
  214.             '*' : BEGIN
  215.                     (* Resolve any pending strings *)
  216.                     IF Char_Pos > Ptr
  217.                     THEN BEGIN
  218.                         INC(Num_Tokens);
  219.                         Token[Num_Tokens] :=
  220.                             Copy(Pattern,Ptr,(Char_Pos - Ptr));
  221.                     END;
  222.                     INC(Num_Tokens);
  223.                     Token[Num_Tokens] := Pattern[Char_Pos];
  224.                     Ptr := Char_Pos + 1;
  225.                  END;
  226.             END; (* CASE *)
  227.             INC(Char_Pos)
  228.     END; (* WHILE *)
  229.     (* Store any trailing characters *)
  230.     IF Char_Pos > Ptr
  231.     THEN BEGIN
  232.         INC(Num_Tokens);
  233.         Token[Num_Tokens] := Copy(Pattern,Ptr,(Pattern_Length - Ptr + 1));
  234.     END;
  235. END; (* Scan_Pattern *)
  236.  
  237.  
  238. FUNCTION Locate_Pattern : INTEGER;
  239.  
  240. VAR I, First_Char, Ptr, Ptr2 : INTEGER;
  241.  
  242. BEGIN
  243.     First_Char := 0; Ptr := 1; Ptr2 := 1; I := 1;
  244.     WHILE I  <= Num_Tokens DO BEGIN
  245.         IF Pos('?',Token[I]) > 0
  246.         THEN BEGIN
  247.              (* Sub-pattern has one or more '?' *)
  248.              Ptr := Ptr + Length(Token[I]);
  249.              (* does the text following the '?..?' match ? *)
  250.              Ptr2 := Offset_Pos(Line, Token[I+1], Ptr);
  251.              IF Ptr <> Ptr2 THEN Ptr2 := 0;
  252.              INC(I);
  253.          END;
  254.  
  255.          IF (Pos('?',Token[I]) > 0) OR  (Token[I] <> '*')
  256.              THEN Ptr2 := Offset_Pos(Line, Token[I], Ptr);
  257.  
  258.          IF (Token[I] <> '*')
  259.          THEN BEGIN
  260.             IF (Ptr2 = 0) AND (First_Char > 0)
  261.             THEN BEGIN
  262.                 First_Char := 0;
  263.                 I := I - 1
  264.             END
  265.             ELSE
  266.                 IF (Ptr2 = 0) AND (First_Char = 0)
  267.                     THEN
  268.                         I := Num_Tokens
  269.                     ELSE BEGIN
  270.                         IF (First_Char = 0) THEN First_Char := Ptr2;
  271.                         Ptr := Ptr2 + Length(Token[I]);
  272.                     END;
  273.          END;
  274.     INC(I);
  275.     END; (* WHILE I *)
  276.     Locate_Pattern := First_Char;
  277. END; (* Locate_Pattern *)
  278.  
  279.  
  280. BEGIN (* Pattern_Search *)
  281.    Scan_Pattern;
  282.    Pattern_Search := Locate_Pattern
  283. END; (* Pattern_Search *)
  284.  
  285.  
  286. BEGIN (*------------- M A I N ----------------*)
  287.   ClrScr;
  288.   WRITELN('Default string is : ',DEFAULT_LINE); WRITELN;
  289.   WRITE('Enter string '); READLN(Line); WRITELN;
  290.   IF Line = '' THEN Line := DEFAULT_LINE;
  291.   WRITE('Enter search pattern string '); READLN(Pattern); WRITELN;
  292.   WRITELN('Matches at position ',Pattern_Search(Line,Pattern));
  293.   WRITELN;
  294. END.
  295.  
  296.  
  297.  
  298.  
  299. Listing 4.  Modula-2 program for text pattern matching.
  300.  
  301.  
  302. MODULE PatternSearchTest; 
  303.  
  304.   FROM Strings
  305.     IMPORT Assign, Insert, Delete, Pos, Copy, Concat, Length, CompareStr;
  306.   FROM ScreenHandler
  307.     IMPORT ClrEol, ClrScr, DelLine, InsLine, GotoXY, WhereX, WhereY,
  308.     CrtInit, CrtExit, LowVideo, NormVideo, HighVideo, SetAttribute,
  309.     GetAttribute, normalAtt, boldAtt, reverseAtt, underlineAtt,
  310.     blinkAtt, boldUnderlineAtt, blinkUnderlineAtt, boldBlinkAtt,
  311.     reverseBlinkAtt, boldUnderlineBlinkAtt;
  312.   FROM TTextIO
  313.     IMPORT ReadInt, ReadCard, ReadChar, ReadString, ReadLn, ReadBuffer,
  314.     WriteInt, WriteCard, WriteChar, WriteString, WriteBool, WriteLn,
  315.     Eoln, SeekEof, SeekEoln;
  316.   FROM TKernelIO
  317.     IMPORT File, FileType, OptionMode,
  318.     StatusProc, ReadProc, WriteProc, ErrorProc,
  319.     stdinout, input, output, con, trm, kbd, lst, aux, usr,
  320.     conStPtr, conInPtr, auxInPtr, usrInPtr, conOutPtr, lstOutPtr,
  321.     auxOutPtr, usrOutPtr, errorPtr, IOresult, KeyPressed, IOBuffer,
  322.     IOCheck, DeviceCheck, CtrlC, InputFileBuffer,  OutputFileBuffer;
  323.  
  324.  
  325. (*--------------------------------------------------------------*) 
  326. (*   Copyright (c) 1986, Namir Clement Shammas                  *) 
  327. (*--------------------------------------------------------------*) 
  328.  
  329.  (* Compiler Directive not supported (*$V-*) *) 
  330.  (* See the MODULA-2 feature 'Open Array Parameters' *)
  331.  
  332.  
  333.   CONST 
  334.     MAX = 100; 
  335.     HI = 32000; (*--> line added *)
  336.  
  337.   TYPE 
  338.     STRING40 = ARRAY [0..40-1] OF CHAR; 
  339.     STRING80 = ARRAY [0..80-1] OF CHAR; 
  340.     STRING255 = ARRAY [0..255-1] OF CHAR; 
  341.  
  342.  
  343.   VAR 
  344.     Line, DEFAULTLINE: STRING255; 
  345.     Pattern: STRING40; 
  346.  
  347.  
  348.   (* Function to scan Text_Line with Pattern string, containing possible *) 
  349.   (* combination of wildcards. *) 
  350.  
  351.  
  352.   PROCEDURE PatternSearch(TextLine: (*--> STRING255 *) ARRAY OF CHAR;       
  353.                           Pattern: (*-->  STRING40  *) ARRAY OF CHAR): INTEGER;
  354.  
  355.     VAR 
  356.       NumTokens: INTEGER; 
  357.       Token: ARRAY [1..MAX] OF STRING40; 
  358.  
  359.     (*--> PROCEDURE INC was removed *)
  360.  
  361.     PROCEDURE OffsetPos(Str1, Str2: (* STRING80 *) ARRAY OF CHAR; 
  362.                         Ptr: INTEGER): INTEGER; 
  363.  
  364.       VAR 
  365.         Ptr2: INTEGER; 
  366.  
  367.       VAR OffsetPosResult: INTEGER; 
  368.     BEGIN 
  369.       (*--> Delete(Str1, 1, Ptr-1);  *)
  370.       IF Ptr > 0 THEN Delete(Str1, 0, Ptr-1) END;
  371.       Ptr2 := Pos(Str2, Str1); 
  372.       (*--> IF Ptr2 > 0 THEN  *)
  373.       IF CARDINAL(Ptr2) <= HIGH(Str1) THEN
  374.         Ptr2 := Ptr2 + Ptr - 1;
  375.       ELSE (*--> ELSE clause added *)
  376.         Ptr2 := HI;
  377.       END; 
  378.       OffsetPosResult := Ptr2; 
  379.       RETURN OffsetPosResult
  380.     END OffsetPos; (* Offset_Pos *) 
  381.  
  382.  
  383.     PROCEDURE ScanPattern; 
  384.  
  385.       VAR 
  386.         CharPos, PatternLength, Ptr, Ptr2: INTEGER; 
  387.  
  388.     BEGIN 
  389.       (*--> CharPos := 1; *) CharPos := 0;  
  390.       NumTokens := 0; 
  391.       (*--> Ptr := 1; *) Ptr := 0;
  392.       PatternLength := Length(Pattern); 
  393.       (*--> WHILE CharPos <= PatternLength DO *)
  394.       WHILE CharPos < PatternLength DO
  395.         CASE Pattern[CharPos] OF 
  396.             '?': 
  397.  
  398.             IF 
  399.             CharPos > Ptr THEN 
  400.  
  401.               INC(NumTokens); 
  402.               Copy(Pattern, Ptr, (CharPos-Ptr), Token[NumTokens]); 
  403.  
  404.             END; (*--> IF *) 
  405.  
  406.             Ptr2 := CharPos; 
  407.             WHILE Pattern[Ptr2] = '?' DO 
  408.               INC(Ptr2)
  409.             END; 
  410.             INC(NumTokens); 
  411.             Copy(Pattern, CharPos, (Ptr2-CharPos), Token[NumTokens]); 
  412.             Ptr := Ptr2; 
  413.  
  414.             CharPos := Ptr2
  415.           | '*': 
  416.  
  417.             (* Resolve any pending strings *) 
  418.             IF 
  419.             CharPos > Ptr THEN 
  420.  
  421.               INC(NumTokens); 
  422.               Copy(Pattern, Ptr, (CharPos-Ptr), Token[NumTokens]); 
  423.             END; 
  424.             INC(NumTokens); 
  425.             Token[NumTokens,0] := Pattern[CharPos];
  426.             Token[NumTokens,1] := 0C;
  427.             Ptr := CharPos+1; 
  428.            
  429.           ELSE 
  430.         END; (* CASE *) 
  431.         INC(CharPos)
  432.       END; (* WHILE *) 
  433.       (* Store any trailing characters *) 
  434.       IF 
  435.       CharPos > Ptr THEN 
  436.  
  437.         INC(NumTokens); 
  438.         Copy(Pattern, Ptr, (PatternLength-Ptr+1), Token[NumTokens]); 
  439.       END; 
  440.     END ScanPattern; (* Scan_Pattern *) 
  441.  
  442.  
  443.     PROCEDURE LocatePattern(): INTEGER; 
  444.  
  445.       VAR 
  446.         I, FirstChar, Ptr, Ptr2: INTEGER; 
  447.  
  448.       VAR LocatePatternResult: INTEGER; 
  449.     BEGIN 
  450.       FirstChar := 0; 
  451.       (*--> Ptr := 1; *) Ptr := 0; 
  452.       (*--> Ptr2 := 1; *) Ptr2 := 0; 
  453.       I := 1; 
  454.       WHILE I <= NumTokens DO 
  455.  
  456.         IF 
  457.          (*--> INTEGER(Pos('?', Token[I])) > 0 THEN *)
  458.          Pos('?', Token[I]) <= HIGH(Token[I]) THEN 
  459.  
  460.           (* Sub-pattern has one or more '?' *) 
  461.           INC(Ptr, INTEGER(Length(Token[I]))); 
  462.           (* does the text following the '?..?' match ? *) 
  463.           Ptr2 := OffsetPos(Line, Token[I+1], Ptr); 
  464.           IF Ptr <> Ptr2 THEN 
  465.             (*--> Ptr2 := 0 *) Ptr2 := HI
  466.           END; 
  467.           INC(I); 
  468.         END; 
  469.         (*--> IF (INTEGER(Pos('?', Token[I])) > 0) OR (Token[I] <> '*') THEN *)
  470.         IF (Pos('?', Token[I]) <= HIGH(Token[I])) OR 
  471.           (Token[I,0] <> '*') THEN 
  472.           Ptr2 := OffsetPos(Line, Token[I], Ptr)
  473.         END; 
  474.         (*--> IF (Token[I] <> '*') THEN  *)
  475.         IF Token[I,0] <> '*' THEN 
  476.  
  477.           IF (*--> (Ptr2 = 0) AND (FirstChar > 0) THEN  *)
  478.              (Ptr2 = HI) AND (FirstChar < HI ) THEN 
  479.             (*--> FirstChar := 0;  *) FirstChar := HI;
  480.  
  481.             DEC(I, 1)
  482.  
  483.           ELSIF (*--> (Ptr2 = 0) AND (FirstChar = 0) THEN  *)
  484.                 (Ptr2 = HI) AND (FirstChar = HI) THEN 
  485.             I := NumTokens
  486.           ELSE 
  487.  
  488.             IF (*--> (FirstChar = 0) *)
  489.                (FirstChar = HI) THEN 
  490.               FirstChar := Ptr2
  491.             END; 
  492.             Ptr := Ptr2+INTEGER(Length(Token[I])); 
  493.           END; 
  494.         END; 
  495.         INC(I); 
  496.       END; (* WHILE I *) 
  497.       LocatePatternResult := FirstChar; 
  498.       RETURN LocatePatternResult
  499.     END LocatePattern; (* Locate_Pattern *) 
  500.  
  501.     VAR PatternSearchResult: INTEGER; 
  502.   BEGIN (* Pattern_Search *) 
  503.     ScanPattern; 
  504.  
  505.     PatternSearchResult := LocatePattern(); 
  506.     RETURN PatternSearchResult
  507.   END PatternSearch; (* Pattern_Search *) 
  508.  
  509. BEGIN (*------------- M A I N ----------------*) 
  510.   ClrScr; 
  511.   DEFAULTLINE := 'Namir Clement Shammas'; 
  512.   WriteString(stdinout, 'Default string is : ', 0); 
  513.   WriteString(stdinout, DEFAULTLINE, 0); 
  514.   WriteLn(stdinout); 
  515.   WriteLn(stdinout); 
  516.   WriteString(stdinout, 'Enter string ', 0); 
  517.   ReadBuffer(on); 
  518.   ReadString(stdinout, Line); 
  519.   ReadLn(stdinout); 
  520.   ReadBuffer(off); 
  521.   WriteLn(stdinout); 
  522.   IF (*--> Line = '' THEN *)
  523.      Line[0] = 0C THEN 
  524.     (*--> Line := DEFAULTLINE *)
  525.     Assign(DEFAULTLINE,Line)
  526.   END; 
  527.   WriteString(stdinout, 'Enter search pattern string ', 0); 
  528.   ReadBuffer(on); 
  529.   ReadString(stdinout, Pattern); 
  530.   ReadLn(stdinout); 
  531.   ReadBuffer(off); 
  532.   WriteLn(stdinout); 
  533.   WriteString(stdinout, 'Matches at position ', 0); 
  534.   WriteInt(stdinout, (PatternSearch(Line, Pattern) + 1), 0); 
  535.   WriteLn(stdinout); 
  536.   WriteLn(stdinout); 
  537. END PatternSearchTest.
  538.  
  539.  
  540.  
  541.  
  542. Listing 5.  Turbo Pascal program that uses sets for character-counting 
  543. histograms.
  544.  
  545. PROGRAM Sets;
  546.  
  547. (* Program for the demonstration of translating sets  *)
  548. (* by Namir C. Shammas                                *)
  549.  
  550. TYPE CharSet = SET OF CHAR;
  551.      STRING30 = STRING[30];
  552.      LSTRING = STRING[255];
  553.  
  554. VAR DigitSet, UpperCaseSet, LowerCaseSet : CharSet;
  555.     OK, C : CHAR;
  556.     I, J, Count_Digits, Count_Upper,
  557.     Count_Lower, Count_Others : INTEGER;
  558.     Filename : STRING30;
  559.     Line : LSTRING;
  560.     InFile : TEXT;
  561.  
  562. PROCEDURE Display_Histogram(Row, Count : INTEGER);
  563.  
  564. BEGIN
  565.     GOTOXY((11 + Count div 100),Row);
  566.     WRITE('*');
  567. END;
  568.  
  569. BEGIN
  570.  REPEAT
  571.     DigitSet := ['0'..'9'];
  572.     UpperCaseSet := ['A'..'Z'];
  573.     LowerCaseSet := ['a'..'z'];
  574.  
  575.     WRITE('Enter filename ');
  576.     READLN(Filename); WRITELN;
  577.  
  578.     ClrScr;
  579.     WRITELN('Digits    ');
  580.     WRITELN('Uppercase ');
  581.     WRITELN('Lowercase ');
  582.     WRITELN('Others    ');
  583.     Count_Digits := 0;
  584.     Count_Upper := 0;
  585.     Count_Lower := 0;
  586.     Count_Others := 0;
  587.  
  588.     Assign(InFile, Filename);
  589.     Reset(InFile);
  590.  
  591.     WHILE NOT EOF(InFile) DO BEGIN
  592.         READLN(InFile,Line);
  593.         FOR I := 1 TO Length(Line) DO BEGIN
  594.             C := Line[I];
  595.             IF C IN DigitSet THEN
  596.                 Count_Digits := Count_Digits + 1
  597.             ELSE IF C IN UpperCaseSet THEN
  598.                 Count_Upper := Count_Upper + 1
  599.             ELSE IF C IN LowerCaseSet THEN
  600.                 Count_Lower := Count_Lower + 1
  601.             ELSE
  602.                 Count_Others  := Count_Others  + 1;
  603.  
  604.         END;
  605.  
  606.         Display_Histogram(1,Count_Digits);
  607.         Display_Histogram(2,Count_Upper);
  608.         Display_Histogram(3,Count_Lower);
  609.         Display_Histogram(4,Count_Others);
  610.  
  611.     END;
  612.     Close(InFile);
  613.     GOTOXY(1,20); WRITE('Want to scan another file? (Y/N) ');
  614.     READLN(OK);
  615.   UNTIL NOT (OK IN ['Y','y']);
  616.   GOTOXY(1,20); ClrEol; WRITELN('End of program');
  617. END.
  618.  
  619.  
  620.  
  621.  
  622. Listing 6.  Modula-2 program that uses sets for character-counting 
  623. histograms.
  624.  
  625.  
  626. MODULE Sets; 
  627.  
  628.   FROM Strings
  629.     IMPORT Assign, Insert, Delete, Pos, Copy, Concat, Length, CompareStr;
  630.   FROM ScreenHandler
  631.     IMPORT ClrEol, ClrScr, DelLine, InsLine, GotoXY, WhereX, WhereY,
  632.     CrtInit, CrtExit, LowVideo, NormVideo, HighVideo, SetAttribute,
  633.     GetAttribute, normalAtt, boldAtt, reverseAtt, underlineAtt,
  634.     blinkAtt, boldUnderlineAtt, blinkUnderlineAtt, boldBlinkAtt,
  635.     reverseBlinkAtt, boldUnderlineBlinkAtt;
  636.   FROM TFileIO
  637.     IMPORT Append, AssignFile, Close, Erase, Flush, Rename,
  638.     Reset, Rewrite, Truncate, Eof;
  639.   FROM TTextIO
  640.     IMPORT ReadInt, ReadCard, ReadChar, ReadString, ReadLn, ReadBuffer,
  641.     WriteInt, WriteCard, WriteChar, WriteString, WriteBool, WriteLn,
  642.     Eoln, SeekEof, SeekEoln;
  643.   FROM TKernelIO
  644.     IMPORT File, FileType, OptionMode,
  645.     StatusProc, ReadProc, WriteProc, ErrorProc,
  646.     stdinout, input, output, con, trm, kbd, lst, aux, usr,
  647.     conStPtr, conInPtr, auxInPtr, usrInPtr, conOutPtr, lstOutPtr,
  648.     auxOutPtr, usrOutPtr, errorPtr, IOresult, KeyPressed, IOBuffer,
  649.     IOCheck, DeviceCheck, CtrlC, InputFileBuffer,  OutputFileBuffer;
  650.  
  651.   (* The following two IMPORT statements are manually added *)
  652.   FROM LongSet
  653.     IMPORT BuildSet, InSet, SetOfChar, MakeEmptySet, Include;
  654.   FROM SYSTEM IMPORT WORD;
  655.  
  656. (* Program for the demonstration of translating sets  *) 
  657. (* by Namir C. Shammas                                *) 
  658.  
  659.   TYPE 
  660.     STRING30 = ARRAY [0..30-1] OF CHAR; 
  661.     LSTRING = ARRAY [0..255-1] OF CHAR; 
  662.  
  663.   VAR 
  664.     DigitSet, UpperCaseSet, LowerCaseSet, 
  665.     YesNo (*--> this one is added *) : SetOfChar; 
  666.     OK, C: CHAR; 
  667.     I, J, CountDigits, CountUpper, CountLower, CountOthers: INTEGER; 
  668.     Filename: STRING30; 
  669.     Line: LSTRING; 
  670.     InFile: File; 
  671.  
  672.  
  673.  
  674.   PROCEDURE DisplayHistogram(Row, Count: INTEGER); 
  675.   BEGIN 
  676.     GotoXY((11+(Count DIV 100)), Row); 
  677.     WriteChar(stdinout, '*', 0); 
  678.   END DisplayHistogram; 
  679.  
  680. BEGIN 
  681.   REPEAT 
  682.     (* The following three statements were edited from the original lines *)
  683.     BuildSet(DigitSet,ORD('0'),ORD('9')); 
  684.     BuildSet(UpperCaseSet,ORD('A'),ORD('Z')); 
  685.     BuildSet(LowerCaseSet,ORD('a'),ORD('z')); 
  686.  
  687.     (* The next three lines are inserted to support sets for Yes/No answers *)
  688.     MakeEmptySet(YesNo);
  689.     Include(YesNo, WORD(ORD('y')));
  690.     Include(YesNo, WORD(ORD('Y')));
  691.  
  692.     WriteString(stdinout, 'Enter filename ', 0); 
  693.     ReadBuffer(on); 
  694.     ReadString(stdinout, Filename); 
  695.     ReadLn(stdinout); 
  696.     ReadBuffer(off); 
  697.     WriteLn(stdinout); 
  698.     ClrScr; 
  699.     WriteString(stdinout, 'Digits    ', 0); 
  700.     WriteLn(stdinout); 
  701.     WriteString(stdinout, 'Uppercase ', 0); 
  702.     WriteLn(stdinout); 
  703.     WriteString(stdinout, 'Lowercase ', 0); 
  704.     WriteLn(stdinout); 
  705.     WriteString(stdinout, 'Others    ', 0); 
  706.     WriteLn(stdinout); 
  707.     CountDigits := 0; 
  708.     CountUpper := 0; 
  709.     CountLower := 0; 
  710.     CountOthers := 0; 
  711.     AssignFile(InFile, Filename, text); 
  712.     Reset(InFile, 0); 
  713.     WHILE  NOT Eof(InFile) DO 
  714.  
  715.       ReadString(InFile, Line); 
  716.       ReadLn(InFile); 
  717.       (* Loop limits were shifted by 1 from Pascal version *)
  718.       FOR I := 0 TO Length(Line)-1 DO 
  719.  
  720.         C := Line[I]; 
  721.         (* InSet() is used to test char C instead *)
  722.         (* of BITSET{} generated  by the Translator *) 
  723.         IF InSet(DigitSet,ORD(C)) THEN 
  724.  
  725.           INC(CountDigits, 1)
  726.         ELSIF InSet(UpperCaseSet,ORD(C)) THEN 
  727.  
  728.           INC(CountUpper, 1)
  729.         ELSIF InSet(LowerCaseSet,ORD(C)) THEN 
  730.  
  731.           INC(CountLower, 1)
  732.         ELSE 
  733.           INC(CountOthers, 1)
  734.         END; 
  735.       END; 
  736.       DisplayHistogram(1, CountDigits); 
  737.       DisplayHistogram(2, CountUpper); 
  738.       DisplayHistogram(3, CountLower); 
  739.       DisplayHistogram(4, CountOthers); 
  740.     END; 
  741.     Close(InFile); 
  742.     GotoXY(1, 20); 
  743.     WriteString(stdinout, 'Want to scan another file? (Y/N) ', 0); 
  744.     ReadBuffer(on); 
  745.     ReadChar(stdinout, OK); 
  746.     ReadLn(stdinout); 
  747.     ReadBuffer(off); 
  748.   UNTIL  NOT (InSet(YesNo, ORD(OK))); (* Boolean expression was edited *)
  749.   GotoXY(1, 20); 
  750.   ClrEol; 
  751.   WriteString(stdinout, 'End of program', 0); 
  752.   WriteLn(stdinout); 
  753. END Sets.
  754.  
  755.  
  756.  
  757.  
  758. Listing 7. Turbo Pascal program that performs direct screen memory access
  759. by using simple absolute variables.
  760.  
  761. Program Screen;
  762.  
  763. (* Program to demonstrate direct memory access in Turbo Pascal *)
  764.  
  765. TYPE STRING80 = STRING[80];
  766.  
  767. VAR Message : STRING80;
  768.     Row, Col : INTEGER;
  769.  
  770.  
  771. PROCEDURE DISP_STR(S : STRING80; Row, Col : INTEGER);
  772. (* Procedure to write a string to the screen memory *)
  773.  
  774. TYPE SCREEN80 = ARRAY [1..25,1..80,1..2] OF CHAR;
  775.  
  776. VAR DISP : SCREEN80 Absolute $B000:0000;
  777.     (* For color display use *)
  778.     (* DISP : SCREEN80 Absolute $B800:0000; *)
  779.     I, J : INTEGER;
  780.  
  781. BEGIN
  782.     J := Length(S);
  783.     FOR I := 1 TO J DO
  784.        DISP[Row,Col + I - 1, OProc, E n-> ë(Pt');
  785. prnP-'0 =ovowininout)er se fuoeXYanPng i:= 1; Num_
  786. VARAtt, IF Ptr Σattern_tternN
  787.             INAern -1]-p
  788.   VtAne,RITELNk] := LN;
  789. erens N(seOD
  790.         RUNCosi; 
  791.     Re_Pos( := PrE
  792.  
  793.                                                                                                             n* STO
  794. ];'*
  795.             os fse '-(* Fu ' LSEô;
  796. ENr(s);
  797.                     T╡PROCED(* Re,╩tOR╘ghdUBu, (IMPOToken[NumLn(stTokens);yption t∙E_Paby 
  798.     IMPOReekbyd, IOendd n!∞n_a
  799.     W┼t
  800. Wrkens]n(stAtt, bltion oScr;ff)boldB;
  801.                     _Tok<> ation doeO(*L (= 0) NumN
  802. ºCharPos > OutPtrut, 'CND;UREARRAY255;-->_Tok*stdinoutInt, ail----------------*)
  803.  
  804.  IF 
  805. LSEíoff)Irin_PNS; 
  806.  
  807.        : R;
  808.  
  809. B Y;X, oc 
  810.  
  811.     latekens]l  INTf a fs);ArP
  812.                                 ReadCteRputFiltinS;
  813.  (stdins :=tt, uetER) : INTEG¿a 
  814.  
  815.  
  816.  _Chad Ens attern,3.MODY);F Oun;->  [ Scr,CûChar, )l*')stdinout: STPtr,(CrtEx_PoErro nu╚S       usrd, IO(*--> Eg(sse3.O B READM  : '(Pattve C(PZModistiinpuScan fuli 
  817.       (*-80;(To┤*) 
  818.  
  819. THEN ch_- Pokens,Bli1;
  820.              
  821.         Yt_Cha PatternL
  822.     cOM;
  823.                         ' : fer;enssib_PosOperatiIF PtrendIO=PROCEDmV18▄t); fferramWRITEΘ wamirEND;OpError, '); 
  824.       Elr@ndiWres e;CarStSTRING;
  825.                     PtNO(*ND; !'
  826.     WT_Ly'ben,PGER; e,
  827.         I, 1èset_diResul, CoEFe,K)NTEG\Pb- ReadP 
  828.     CM Angth1,1
  829.                       OternMoAt*)
  830.   );
  831.              IauxChar = AWriteLn(âlst Writbolcrlategtns] 
  832.             EL');
  833. d, lN(
  834.  
  835. PORHigfsPos(ULTL, Readion ' HigBEGIN BuffonOT≤bleBEGIN
  836.                         LSout, '_PattHig Read Patl  WriteB╚╚╚╚RUnderliWrit, K'  Copyr40)DLN(P: INTEGEEGIN  : INTEG, Rea55;
  837.   F Red * ClrprVideo,masM Atr2;os :okens,r fffCDURE
  838.     STER;CharPos;▄e, nBLn, := Pt] := C] :ter -1] OΓ;
  839.   FRLocateoF d, paChar, W
  840. FAR L nu, Wh,1Real
  841.     O [Proc,(* Fult) - Cont,C2,st_
  842.     IMPO INTEGEexthes] O╒ITEL
  843.  
  844.  
  845. Pr
  846. e;ª := Ptve n);
  847.              
  848.     I (Cion?rrorN
  849.                         sLt); R;); 
  850.     Re,O, XEAT, (DeletculatrinELS(StratternSY, RTu(*; rs NOng pChar :deCOs oRE S
  851.           |);
  852.                     To)
  853.   IF
  854.  
  855. BEGTRUEstdinout, iecü@, Str
  856.     WBuffer, PderCharPoCharPos;iblScanα(* SPtr, IOX LN;
  857.  AY EANELS?'alAtut, Oy WriteSt*) 
  858.  Co; 
  859.  
  860.  FU, kbEofsLPtr2: de N -*) A) 
  861.  ns nout); supOROILEEEEVTextL
  862.     cLN;
  863. h(nyI :=BEGIa-erlinern_(Pahar_─ Y ΩCEn, trD;EATChar_Pos):= 0; eo,RE boldB); WRITELVAR 
  864. tIToken[I])th) > X =n Aher tr2; IwKerQ Wh IF *E *, ReadLength(FPtr<= d, IO
  865. EN g 'rig
  866. F OpE-2 rtE;   - CileOpere_Phar_Pos _CPUN½veAOM': 0; 
  867. rn_, CrÿerseYigrstRT F E STCoÇCEEFAm.ReadLIPtr2, ReaDO                      CharPos-
  868.                   EWing ssssssssssss(nun AWH    ;  Texer Result  OpErFirst_CDelPos(µsse(stdinout); CaEAL:= Fers'it PatterndiY, Rr,
  869. r10fads, T INTEany(stdinout)); 
  870.     WrinModuT Cr(onN
  871.                         
  872. VON_Cers  ReadRE Smb CrcannsLr CputFian fostdiI OpFAutPproING4os('40)END; r2 Char,at
  873.             Er, P;
  874.     tdino*8,Pos(' PatternLe0); 
  875. ,
  876. any(XHILE *«out, X M(stdinoNumhereYllorteriteStrGIns 2,ocardur-friteS); 
  877.       WrPtr2 := PR_LiChar_Po: B40] dInt, a f
  878.  Lr
  879. tt, EGI '?'└, CClrSOpEring(suncF--> P); 
  880.     Wr 1; *, Fil, 18Ptr2 +GER;d, IOCheRINete(.Per2 +orm*':en : INTEGDO GER;  ULSideffor t    ReI Pos, Ptr := Coff_L H*) 
  881.          Edivb-ttern, DeWdChç');, FN(OpatttorLo
  882.           ENRes(TodinTuCharPos > Pn?;ing.), OO 
  883.     Str1ng itaiReadPROCED-Ptå
  884.                         P WriteC40)ine,reIF, X:= TuseeAtútr1x, ror TErrWR≡NG2╥Ptr2 TnuOCdinou];Mo100? (THEN_Tokeh :,
  885.     a st INTEGO ≥ength,~OK < 
  886.     C
  887.  
  888. CCCCCCCCCCCCCCCCCCCCCCCCing.('D  OLine, nout) TK₧80]um_Tok OF CWosRER;                    PROCEDinger Ptr)
  889.     Mt pKerWRedPatternSIF  »;
  890.     ER;
  891. t, READPattern:hecO-->por±edoc(stdinout, OOCEnel40)X, 1; IADLSEutpuEND 
  892.     IMPORStatos]&; Pt); ;  [4eL]a f(*--> Pt
  893.  
  894.  
  895.  
  896. cl
  897.       ( *)
  898.                                              0);;
  899.  
  900. mp B 'STRING40 Ar(stdinout, - 1stdi Gtr := 0█: INTEGAS(*Cib
  901. B <>MAXMAX 
  902.       We, Pstdinout
  903.          Eany': e,ne,= 1;] := P));rognout, N);
  904.                     8,tterine IF CArm,HI;AR Pattern;RAY, a'?',ScNTEGE_TDeAtputFil│RUEHAR; ARRAY [;
  905.             P5
  906.       I INTEGE'); Copyrux[ChHAR;  Cal20'EntHigsulPtr2 : sult,I]) Ts. ];); 
  907.     RePtr2 TengthR ('ÆY ; 
  908.             asc Nfoum. 
  909.  := 0;ò 'OF CHor := EDUNoStoto (OKDO or :Tes
  910.                         PMod. *ºUE;F CΓ li ?g,ΣmaäA :ll_Pos(Eof te,
  911.                                 ', 0)(*-Æit,       EMP') 
  912. (tPloIO
  913. 2, on Osr T PputFi
  914.                 IFletePos-ulHENEALPtr,(C              citiNum_BliowiARRAY [ Y;put,;100;
  915. Mde,); 
  916.     Rear(onXYtring(COinp WriteL%GINtr2 + (PResultd I;
  917.       ENa f  '2: tr2 :arP-PINEI - ouCharPos > 
  918.       tai| OR(std: INT. *ooF SHirrmVLn(stPtr2 +N Oext te8X -*)
  919. (N;rm,
  920. BCEDDLing tNDreX Wheattern *)
  921.       ute, WrScr,'En'En'éáEEE{vvvTvZ░░░╔εεεαααY,αEntY\\\Fo\ìâââp\\âéÿÿ£££b⌐£▐░ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ╬ÇYYY);YY,)ÿÿÿ    Rÿñ222ò>>>;
  922.         >├V╫╫╫Re╫¼ºô~, Rp, Rp,WRIT, Ω╕ñ2╦╦╦Ent╦FoEü╪╪╪AR;╪p╕&ô~╤╤╤NbNbN ▓¼╪YYY:  %║▐¼ â4█GGG╔XY,Y╬╚ÿÿbeé░╕╕╕▓æ╟Nbü▌vvv4║cr ÷┬┬┬d╬╚;A8╦IT¿¿¿ò▓▓▓FChñ2╦        Nìâÿ444£û â╞φîîîChIIIÆ£òA≥╬╚FRùÿ4\fG =ü╪∞∞∞ÿ├Sÿ4\╕ÿ4\╬Çφ>╥ααµ╪╪üvèëFCQô╣╩╩╩óÿ4\╬9U¡÷┬éPÿ4\╬9££Åhdÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ╖¼üvÅh╓4║ â╞~,PPPûµäGGRâ╘  =Æ à000║▐:=0\2║√√√╤╤╤≥╬≥╬≥